SuperHack/SuperHack CD.bin/CODING/WINDOWS/LZAPI.ZIP/BCKUP.ZIP/BCKUP.PAS

Pascal/Delphi Source File | 1995-03-21 | 15.5 KB | 525 lines

{----------------------------------------------------------------------*
 *
 *    B C K U P . P A S -     Dipl. Ing. Bernd Herd
 *                Heidelberger Landstr. 316
 *                64297 Darmstadt
 *                Germany
 *                Tel./Fax: 06151 / 591216
 *    (C) 1994-95 Bernd Herd
 *
 * WLHA.DLL Dynamic Link Library for Microsoft Windows 3.1
 * makes it possible to extract Files from and add Files to LHA-Archives
 * without using LHA.EXE
 *
 * This is a Demonstration Program to show you, how a simple
 * Backup-Solution may work with WLHA.DLL. It is not intended to
 * be a professional Backup Program.
 *
 * You may want to Copy the RC-Resource Files via the Dos-Command-
 * line BRC -R BCKUP.RC before Compiling this Pascal-Program in the IDE.
 *
 * What does this Demo-Program Do?
 * 1. It let's you select some files that shall be compressed
 * 2. When Pressing OK, it will begin to Compress all the selected
 *    Files in one big Temporary Archiv
 * 3. Afterwards it distributes the Big temporary Archiv onto the
 *    Count of Diskettes needed
 * 4. It will add a restore.BAT-Batchfile that can be used to
 *    restore the Files backuped
 *
 *---------------------------------------------------------------}
{$X+}

Uses WLHa,                          { Yeah! }

     Objects,                       { For TCollection }
     WinDos,                        { For FindFirst }
     WinTypes, WinAPI, WinProcs, Win31,
     OWindows, ODialogs,            { OWL }
     BckUpr,                        { Ressource IDs }
     CommDlg,                       { File File Selection Dialog Box }
     Strings,
     ShellApi,                      { For Drag & Drop Support }
     Ms3d;                          { Let's look a little bit less boring }


{ ----------- Let's define a Simple File-Name-Container ------------ }
type PTFile= ^TFile;                         { File Attributes for the Container }
     TFile = object
       Name : Array[0..120] of Char;
       constructor Init( AFile : PChar );
       destructor  Done;
     End;

     PTFileList = ^TFileList;
     TFileList = object(TCollection)
     End;


constructor TFile.Init( AFile : PChar );
Begin
     strcopy(Name, AFile);
End;

destructor  TFile.Done;
Begin
End;

{ ----- It's a good Idea to have a Window in a Windows-Program ---- }

type
   TApp = object(TApplication)
   procedure InitMainWindow; virtual;
end;

type PTBckup = ^TBckup;
     TBckup  = object(TDialog)
     Liste : PListBox;

     procedure SetupWindow; virtual;

     procedure IdAdd    (var Msg: TMessage)  ; virtual ID_FIRST + IDADD;
     procedure Ok       (var Msg: TMessage)  ; virtual ID_FIRST + IDOK;
     procedure WMDropFiles(var Msg: TMessage)  ; virtual WM_FIRST + WM_DROPFILES;

     procedure FilesFromCommandLine;
     procedure FilesFromCommDlg;

     procedure CopyToDiskette(FName : PChar);

     End;

     PAbort = ^TAbort;
     TAbort = object(TDialog)
     procedure Cancel   (var Msg: TMessage)  ; virtual ID_FIRST + IDCANCEL;
     End;


{$R bckup.res}

procedure TApp.InitMainWindow;
begin
   MainWindow := New(PTBckup, init(nil,'DEMO'));
   SetKBHandler(MainWindow);
end;




{ ----------------- Global Variables ------------------------ }
var SourceFiles : TFileList;



{ - FilesFromCommandLine -------------------------------------
  Take the list of Files from the given Command Line
}
procedure TBckup.FilesFromCommandLine;
var  ParamNo : Integer;
     ff      : TSearchRec;
     NextName: String[120];
     Dir     : Array[0..100] of char;
     Name    : Array[0..10]  of char;
     Ext     : Array[0..5]   of char;
     NewName : Array[0..120] of char;
Begin
   for ParamNo:=1 to ParamCount do Begin
     { Extract Directory (if any) to be joined to Wildcard search result again }
     NextName:= ParamStr(ParamNo);
     strpcopy(NewName, NextName );

     FileSplit( NewName, Dir, Name, Ext);

     { Find Files and allow for Wildcards }
     findfirst( NewName, 0, ff);
     Liste^.AddString(NewName);

     while DosError = 0 do Begin
        { Join Wildcard search result and Pathname }
        strcopy(NewName, Dir);
        strcat (NewName, ff.Name);

        { Include FULL Pathname }
        fileExpand(NewName, NewName);

        { Add File to my Container Object }
        Liste^.AddString(NewName);
        SourceFiles.Insert( new (PTFile, Init(NewName) ) );

        { Find the next File that matches our specifications }
        findnext(ff);
     End;
   End;
End;


{ - FilesFromCommDlg ---------------------------------------------------
  Let's give the User a Chance to Hack in some more Files via the
  Common Dialogs Interface }
procedure TBckup.FilesFromCommDlg;
var ofn        : TOpenFileName;
    FilesTable ,                       { Pointer to a  Buffer for the File Names }
    ThisFile   ,
    NextFile   : PChar;                { Pointer to the next File }
    Dir        : array[0..120] of char;
    FullName   : array[0..120] of char;
Begin
  GetMem(FilesTable, 32767);
  strcopy(FilesTable, '*.*');

  FillChar(ofn, sizeof(ofn), 0);

  ofn. lStructSize := sizeof(ofn);
  ofn. hWndOwner   := HWindow;
  ofn. lpstrFilter := 'All Files (*.*)'#0'*.*'#0'Data Base Files(*.db*)'#0'*.db*;*.md*'#0;
  ofn. nFilterIndex:= 1;
  ofn. lpstrFile   := FilesTable;
  ofn. lpstrTitle  := 'Select the Files you wish to backup';
  ofn. Flags       := OFN_FILEMUSTEXIST or OFN_ALLOWMULTISELECT;
  ofn. nMaxFile    := 32767;

  if (GetOpenFileName(ofn)) then Begin
    NextFile := strpos(FilesTable, ' ');
    if NextFile<>NIL Then Begin
      NextFile^:=#0;
      Inc(NextFile);
      strcopy(Dir, FilesTable);

      while (NextFile<>NIL) Do Begin
         ThisFile := NextFile;
         NextFile := strpos(ThisFile, ' ');
         if (NextFile<>NIL) Then begin
             NextFile^:=#0;
             Inc(NextFile);
         End;
         strcopy(FullName, Dir);
         strcat (FullName, '\');
         strcat (FullName, ThisFile);

         Liste^.AddString(FullName);
         SourceFiles.Insert( new (PTFile, Init(FullName) ) );
      End;
    End
  else
    Begin
        SourceFiles.Insert( new (PTFile, Init(FilesTable) ) );
        Liste^.AddString(FilesTable);
    End;
  End;


  FreeMem(FilesTable, 32767);
End;



procedure TBckUp.IdAdd(var Msg: TMessage);
Begin
   FilesFromCommDlg;
End;


procedure TBckUp.WMDropFiles(var Msg: TMessage);
var HDrop : THandle;             { File Managers Drop-Handle }
    News  : Integer;             { Count of New Files }
    i     : Integer;
    TheName : Array[0..144] of char;
Begin
  HDrop := Msg.WParam;
  News  := DragQueryFile(HDrop, $FFFF, NIL, 0);

  for i:=0 to News-1 do Begin
     DragQueryFile(HDrop, i, TheName, sizeof(TheName) );
     SourceFiles.Insert( new (PTFile, Init(TheName) ) );
     Liste^.AddString(TheName);
  End;

  DragFinish(hDrop);
End;




const Reserve = $F000;                  { Reserved Space for every Diskette }

type HFILE = Integer;


procedure CopyFileToDiskette(TmpFil : HFile; TmpSize : LongInt; DiskNo : Integer; BlkSize : LongInt );
var cnt, i : Integer;
    result : Word;
    Outf   : HFile;
    fname  : Array[0..120] of char;
    DiskNoStr: Array[0..5] of char;
    dummy  : TOfStruct;         { Struct for OpenFile }
    IOBuffer : PChar;
Begin
   GetMem(IOBuffer, $4000);
   cnt    :=BlkSize div $4000;
   Str(DiskNo, DiskNoStr);
   StrCopy(FName, 'A:\DISK.');
   strcat (FName, DiskNoStr);
   {$I-}
   Outf := OpenFile(FName, dummy, OF_CREATE or OF_READWRITE);
   If (OutF=-1) then MessageBox(0, 'Fehler: OpenFile gescheitert', 'Backup', MB_oK);
   result := $4000;
   i      :=0;
   while (i<cnt) and (result=$4000) do Begin
      result := _lread(TmpFil, IOBuffer, $4000);
      if (result<>0) and (result<>-1) then
         _lwrite(Outf, IOBuffer, Result);
      Inc(i);
   End;

   _lclose(Outf);
   {$I+}
   FreeMem(IOBuffer, $4000);
End;








{ --------------- Copy temporary File to Diskettes ------------------- }
procedure TBckUp.CopyToDiskette(FName : PChar);
var Answer : Integer;
    DskFree: LongInt;
    Listing: Text;              { A Backup Protocol Listing }
    i      : Integer;
    TmpFil : HFile;             { The tmporary compressed File }
    TmpSize: LongInt;
    dummy  : TOfStruct;         { Struct for OpenFile }

Begin
  DskFree := -1;
  Answer  := IDYES;

  TmpFil  := OpenFile(FName, dummy, OF_READ);
  TmpSize := _llseek(TmpFil, 0, 2);
             _llseek(TmpFil, 0, 0);

  if (TmpFil = -1) or (TmpSize<=0) then
     MessageBox(HWindow, FName, 'Internal Error', MB_OK);

  while (Answer <> IDNO) and
        (DskFree < Reserve) do Begin

     MessageBeep(0);
     Answer := MessageBox(HWindow, 'It would be nice to insert the first Disk into Drive a:\',
                                    'Backup', MB_YESNO or MB_ICONQUESTION);
     if (Answer = IDYES) then Begin
       DskFree := DiskFree(1);
       if (DskFree>Reserve) then Begin

           { ---------- Write the Names of all the Files that have been Saves --------- }
           Assign(Listing, 'A:\BACKUP.LOG');
           rewrite(Listing);

           for i:=0 to SourceFiles.Count-1 do
              writeln(Listing, PTFile(SourceFiles.At(I))^.Name);

           Close(Listing);

           { ---------- Create the Restore - Batch-File ------------------------------- }
           Assign(Listing, 'a:\RESTORE.BAT');
           rewrite(Listing);
           writeln(Listing, '@echo off');
           writeln(Listing, 'if %1X==ToCX goto ToC');
           writeln(Listing, 'c:');
           writeln(Listing, 'md \tmpr');
           writeln(Listing, 'cd \tmpr');
           writeln(Listing, 'Copy a:\restore.bat');
           writeln(Listing, 'restore.bat ToC');
           writeln(Listing, ':ToC');
           for i:=1 to (TmpSize+DskFree-reserve-1) div (DskFree-Reserve) do Begin
              if i<>0 then Begin writeln(Listing, 'echo Please  insert Next Diskette');
                                 writeln(Listing, 'Pause');
                           End;
              writeln(Listing, 'copy a:\DISK.', i);
           End;

           writeln(Listing, 'copy /b DISK.* ARC.LZH');
           writeln(Listing, 'LHA E ARC.LZH');
           writeln(Listing, ':Ende');


           close(Listing);

           { ----------- Copy the Temporary File to the Diskettes --------------------- }
           for i:=1 to (TmpSize+DskFree-Reserve-1) div (DskFree-Reserve) do Begin

              if i<>1 then Begin
                          MessageBeep(0);
                          MessageBox(HWindow, 'It would be nice to insert the next Disk into Drive a:\',
                                       'Backup', MB_OK or MB_ICONQUESTION);
                           End;

              CopyFileToDiskette(TmpFil, TmpSize, i, DskFree-Reserve);
           End;
       End;
     End;
  End;

  _lclose(tmpFil);
  OpenFile(FName, dummy, OF_DELETE);
End;



{ Variables to exchange Informations between main and Callback }
var CancelImmediatly : Boolean;              { True when running LHA and User selected to close it down }
    CountDown        : Integer;              { Coounter for Callback Usage }

{ ---------------- Let's define a Callback Function so the User won't be bored --- }
function BckupCallbck(lhmsg : Integer; p : LPLHHEAD) : LHERR; export;
var Msg : TMsg;
Begin
  Dec(Countdown);
  if (CountDown<0) then Begin
     CountDown:=100;
     if (PeekMessage( Msg, 0, 0, 0, PM_REMOVE)) then Begin
         if (not Application^.ProcessAppMsg(Msg)) then Begin
             TranslateMessage(Msg);
             DispatchMessage(Msg);
         End;
     End;
     if CancelImmediatly
       then BckupCallbck := LHN_STOP
       else BckupCallbck := LHDefCallbck(lhmsg, p);
  End
  else      BckupCallbck := LHDefCallbck(lhmsg, p);
End;
exports  BckupCallbck;


{ ---------------- Abord Dialog Function: Cancel-Button pressed ------ }
procedure TAbort.Cancel (var Msg: TMessage)  ;
Begin
    CancelImmediatly := TRUE;
End;


{ ---------------- Start the BACKUP-Processing.... ------------------- }


procedure TBckUp.Ok(var Msg: TMessage);
var e         : LHERR;                  { Error Message form WLHA.DLL }
    I         : Integer;
    Options   : Integer;                { Options-Parameter for LHAppend }
    FName     : array[0..144] of char;  { Our Temporary File Name }
    ListBoxLine: Integer;
    Abort     : PAbort;
Begin
   { Get a temporary Filename for Our Archiv }
   GetTempFileName(#0, 'LZH', 0, FName);

   { Start the Processing if LHA-Archives via WLHA }
   e := LHInit(HInstance);

   { Initializations }
   CancelImmediatly := False;
   CountDown        := 0;

   { Open an Abort Dialog Box }
   Abort := PAbort( Application^.MakeWindow( new (PAbort, Init(@self, 'ABORT') ) ) ) ;

   if (e = LHE_OK) then Begin

      { ----------- Allow Background processing ------------------ }
      LHSetCallback(@BckupCallbck);

      { ----------- Disable the direct closing of the main Window - }
      EnableWindow(HWindow, False);

      I:=0;
      while (i<SourceFiles.Count) and (e=LHE_OK) and not Cancelimmediatly do Begin

         { A Little bit of a Show for our Users }
         ListBoxLine := SendMessage(Liste^.HWindow, LB_FINDSTRING, 0, LongInt(@PTFile(SourceFiles.At(I))^.Name) );
         Liste^.SetSelIndex(ListBoxLine);

         { The First File need LGA_CREATEARCHIVE }
         if (i=0) then Options := LHA_SHORTNAMES or LHA_CREATEARCHIV
                  else Options := LHA_SHORTNAMES;

         { Let's give the Compression Task to WLHA.DLL }
         e := LHAppend(FName, PTFile(SourceFiles.At(I))^.Name, Options);

         Inc(i);
      End;

     { No more WLHA-Usage }
     LHSetCallback(NIL);
     LHEnd(hInstance);
   End;

   { If there has been any Error, report it... }
   if (e<>LHE_OK) then
      LHErrMsgBox(e);

   { ----------- Ensable the normal Operation of the main Window - }
   EnableWindow(HWindow, True);
   SetFocus(HWindow);

   { Cancel the Abort Window if this has not already been done }
   Abort^.CloseWindow;

   { Now: Copy the Temp-File to the Diskette }
   if (e=LHE_OK) and not CancelImmediatly then Begin
      CopyToDiskette(FName);
      TDialog.Ok(Msg);
   End;
End;






{ ---------------- Interesting Part ... -------------------------------- }
procedure TBckup.SetupWindow;
var rc : TRect;
Begin
   TDialog.SetupWindow;

   GetClientRect(HWindow, rc);

   { --------- Create a Listbox with our File names ---------------------}
   Liste := PListBox(Application^.MakeWindow(new (PListBox, Init(@self, IDFILES, 5, 5, rc.right-10, rc.bottom-60) ))) ;

   { First, it would be a good Idea to find out, what the User wants to Backup,
     so let's look first for a Command Line parameter, and if there is none,
     we use the Windows 3.1 COMMDLG-API }

   if (ParamCount > 0)  { Any parameters on CommandLine ? }
      then FilesFromCommandLine
      else FilesFromCommDlg;

   { ---------- Anyway: Do you like Programs that don't accept Files from WinFile ? ---- }
   DragAcceptFiles(HWindow, TRUE);  { So let's accept Files }

End;


{ ------------------------ Main Program -------------------------------- }
var App : TApp;

Begin

    { In the Main Program we'll only open a litte Listbox-Window...
      nothing special...

      The Interesting parts you'l find in TBckup.SetupWindow
    }

    SourceFiles.Init(100,100);

    App.Init('Test ');
    App.Run;
    App.Done;

End.